home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xrs.bas < prev    next >
Encoding:
BASIC Source File  |  1985-07-21  |  14.3 KB  |  335 lines
  1.  
  2. 10 REM *** PROGRAM FOR XREF & LISTING BASIC (XRS) V-1.1  7/11/85
  3. 20 REM *** Written in BASIC. Should be compiled for speed.
  4. 30 REM *** Much of this program is from SOFTALK Feb. 83 Page 91. Additional
  5. 40 REM *** changes in the print routines by the Atlanta IBM SIG. Current
  6. 50 REM *** changes by G K Hale of Long Communications - Winston-Salem, NC
  7. 60 CLS
  8. 70 CLEAR
  9. 80 KEY OFF
  10. 90 PRINT "Program to XREF and print BASIC programs saved in ASCII format"
  11. 100 PRINT
  12. 110 DEFINT A-Z
  13. 120 PRINT "ASCII FILE TO BE PRINTED --- ";
  14. 130 LINE INPUT PROGRAM$
  15. 140 T$=TIME$:D$=DATE$
  16. 150 PG=1:NL=1
  17. 160 INPUT "Do you want LIST, XREF or BOTH (L/X/B) ";LX$
  18. 170 IF LX$="L" OR LX$="X" OR LX$="B" THEN GOTO 190
  19. 180 PRINT CHR$(7):GOTO 160
  20. 190 IF LX$="L" THEN GOTO 3190
  21. 200 IF LX$="X" THEN GOTO 230
  22. 210 LPRINT TAB(8);PROGRAM$;"  Printed on ";D$;" at ";T$;TAB(60);"PAGE";PG
  23. 220 LPRINT:LPRINT
  24. 230 PRINT
  25. 240 '***---dimension arrays---***
  26. 250 TOT.V=9: MAX.V=TOT.V
  27. 260 DIM F$(9), VAR.REF(600,9)
  28. 270 DIM VAR.NAMES$(600), VAR.TYPE$(600), V.FILED(600), VAR.PTR(600)
  29. 280 DIM VARS.IN.ST$(30), JJ.PTR(36)
  30. 290 NUM.SKIP.WORDS=155: DIM SKIP.WORDS$(155)
  31. 300 GOSUB 1800                              'INITIALIZATION
  32. 310 OPEN PROGRAM$ FOR INPUT AS #1           'Open input file
  33. 320 LINE INPUT #1,ST$                       'Read 1st BASIC statement
  34. 330 IF LX$="X" THEN GOTO 350
  35. 340 LPRINT ST$                              'Send 1st line to printer
  36. 350 OPEN "xref.wrk" AS #2 LEN =42           'Open work file
  37. 360 '***---field statements for work file---***
  38. 370 FIELD #2,2 AS IREC$, 20 AS F.N$
  39. 380 FIELD #2,22 AS D1$,2 AS F$(0),2 AS F$(1),2 AS F$(2),2 AS F$(3),2 AS F$(4)
  40. 390 FIELD #2,32 AS D1$,2 AS F$(5),2 AS F$(6),2 AS F$(7),2 AS F$(8),2 AS F$(9)
  41. 400 FIELD #2,22 AS D1$,2 AS F0$,2 AS F1$,2 AS F2$,2 AS F3$,2 AS F4$
  42. 410 FIELD #2,32 AS D1$,2 AS F5$,2 AS F6$,2 AS F7$,2 AS F8$,2 AS F9$
  43. 420 GOSUB 2110                                 'Get flag settings
  44. 430 GOTO 580
  45. 440 LPRINT TAB(8);PROGRAM$;"   Printed on ";D$;"  at  ";T$;TAB(60);"PAGE";PG
  46. 450 LPRINT:LPRINT
  47. 460 RETURN
  48. 470 ' *********************
  49. 480 ' *     MAIN LOOP     *
  50. 490 ' *********************
  51. 500 '
  52. 510 IF EOF(1) GOTO 2230               'If end, go print
  53. 520 IF LX$="X" THEN GOTO 550
  54. 530 LET NL=NL+1
  55. 540 IF NL=54 THEN LET NL=1:PG=PG+1:LPRINT CHR$(12);:GOSUB 440
  56. 550 LINE INPUT #1,ST$                 'Read Basic statement into st$
  57. 560 IF LX$="X" THEN GOTO 580
  58. 570 LPRINT ST$                        'Send line to printer
  59. 580 VARS.IN.ST = 0                    'Set variables in St$=0
  60. 590 FLAG.GO=FALSE                     'Yes = goto,gosub, or return
  61. 600 IX=INSTR(ST$," ")                 'Find first space in statement
  62. 610 LINE.NUM=VAL(LEFT$(ST$,IX-1))     'Set line number
  63. 620 IF LX$="B" THEN GOTO 640
  64. 630 PRINT LINE.NUM;
  65. 640 IS=IX+1                           'Set is to first char after space
  66. 650 LINE.LEN=LEN(ST$)                 'line.len = length of statement
  67. 660 '
  68. 670 '*******************************************
  69. 680 '*          Loop within statement          *
  70. 690 '*      looking for a charcater (a-z)      *
  71. 700 '*           or <">   or <'>               *
  72. 710 '*      Found: then I=position in st$      *
  73. 720 '*******************************************
  74. 730 '
  75. 740 FOR I = IS TO LINE.LEN
  76. 750  IF VAR$="REM" THEN LSET VAR$=" ": GOTO 510
  77. 760                                    'if "REM", skip 
  78. 770  LSET I$=MID$(ST$,I)               'set I$ to char from statement
  79. 780  IF (I$ >="A" AND I$<="Z") GOTO 950 'If between A&Z then go
  80. 790  IF I$><D.Q$ GOTO 860              'Check for a literal ("xx")
  81. 800  J=INSTR(I+1,ST$,D.Q$)             'Get end of literal
  82. 810  IF J=0 THEN J=LINE.LEN
  83. 820  VAR$=MID$(ST$,I,J-I+1): J=J+1     'Set var$ to literal
  84. 830  VT$="L"                           'Variable type is a Literal
  85. 840  KEEP=XREF.LITERALS                'Do we xref literals?
  86. 850  GOTO 1060
  87. 860  IF I$="'" GOTO 510                  'found comment
  88. 870 NEXT
  89. 880 GOTO 510    'WE FELL THRU LOOP, THUS DONE WITH THIS STATEMENT
  90. 890 '
  91. 900 '   *********************************
  92. 910 '   *      Loop within statement    *
  93. 920 '   *   Looking for end of variable *
  94. 930 '   *********************************
  95. 940 '
  96. 950 FOR J=I+1 TO LINE.LEN
  97. 960  LSET I$=MID$(ST$,J)               'Set I$ to char from statement
  98. 970  IF (I$>="A" AND I$<="Z") OR (I$>="0" AND I$<="9") GOTO 1010
  99. 980  IF INSTR(SPECIAL.CHARS$,I$)>0 GOTO 1000
  100. 990  GOTO 1020                           'Var$ done
  101. 1000  IF I$="(" GOTO 1020                 'var$ done
  102. 1010 NEXT J
  103. 1020 VAR$=MID$(ST$,I,J-1-I+1)            'set var$ to variable
  104. 1030 VT$="V"                              'Variable type is a Variable
  105. 1040 FLAG.GO=(VAR$="GOSUB" OR VAR$="GOTO" OR VAR$="RETURN" OR VAR$="RESUME")
  106. 1050 GOSUB 1670                          'check if we want to xref this
  107. 1060 IF NOT KEEP GOTO 1370
  108. 1070 '***---Already found this var$ in this statement?---***
  109. 1080 '***---if so then skip it---***
  110. 1090 FOR I=1 TO VARS.IN.ST
  111. 1100  IF VAR$=VARS.IN.ST$(I) GOTO 1370   'already used, so skip
  112. 1110 NEXT
  113. 1120 VARS.IN.ST=VARS.IN.ST+1
  114. 1130 VARS.IN.ST$(VARS.IN.ST)=VAR$        'first time
  115. 1140 '***---Find first variable greater or equal to var$---***
  116. 1150 IF VAR$>="A" THEN VAR.SUB=55: GOTO 1180 'set starting point for
  117. 1160 IF VAR$>="1" THEN VAR.SUB=48: GOTO 1180 ' search thru chain
  118. 1170 IV=0: OLD.PTR=0: NEW.PTR=VAR.PTR(0): GOTO 1220
  119. 1180 IV=ASC(VAR$)-VAR.SUB
  120. 1190 OLD.PTR=JJ.PTR(IV-1)
  121. 1200 NEW.PTR=VAR.PTR(OLD.PTR)
  122. 1210 '***---Search thru chain of variables---***
  123. 1220 FOR I=1 TO VARS
  124. 1230  IF VAR.NAMES$(NEW.PTR)>=VAR$ GOTO 1290 'Found
  125. 1240  OLD.PTR=NEW.PTR: NEW.PTR=VAR.PTR(NEW.PTR)
  126. 1250  IF VAR.NAMES$(NEW.PTR)="" GOTO 1290 'End of list
  127. 1260 NEXT
  128. 1270 '***---Not found so add to end of list---***
  129. 1280 NEW.PTR=0: GOTO 1310
  130. 1290 IF VAR.NAMES$(NEW.PTR)=VAR$ THEN I=NEW.PTR: GOTO 1340
  131. 1300 '***var$ not found - create entry, set ptr
  132. 1310 VARS=VARS+1: I=VARS: VAR.PTR(OLD.PTR)=I
  133. 1320 VAR.PTR(I)=NEW.PTR: VAR.NAMES$(I)=VAR$: VAR.TYPE$(I)=VT$
  134. 1330 IF VAR$ > VAR.NAMES$(JJ.PTR(IV)) THEN JJ.PTR(IV)=I
  135. 1340 IF VAR.REF(I,0)=MAX.V THEN GOSUB 1560
  136. 1350 ENTRY=VAR.REF(I,0)+1
  137. 1360 VAR.REF(I,ENTRY)=LINE.NUM: VAR.REF(I,0)=ENTRY
  138. 1370 IS=J
  139. 1380 IF FLAG.GO GOTO 1410      'goto, gosub, or return?
  140. 1390 GOTO 740
  141. 1400 '***get statement numbers
  142. 1410 IF IS>=LINE.LEN GOTO 740
  143. 1420 FOR I=IS TO LINE.LEN
  144. 1430  LSET I$=MID$(ST$,I)
  145. 1440  IF I$>="0" AND I$<="9" GOTO 1480
  146. 1450  IF I$><"," AND I$><" " THEN IS=I: GOTO 740
  147. 1460 NEXT
  148. 1470 IS=I: GOTO 740
  149. 1480 FOR J=I+1 TO LINE.LEN
  150. 1490  LSET I$=MID$(ST$,J)
  151. 1500  IF I$<"0" OR I$>"9" GOTO 1520
  152. 1510 NEXT
  153. 1520 VAR$=MID$(ST$,I,J-I)
  154. 1530 VT$="N"                      'Variable type is a line Number
  155. 1540 IF XREF.LINENUMS THEN GOTO 1160 ELSE IS=J: GOTO 1410
  156. 1550 '*** Write filled group, set up next
  157. 1560 V.FILED(I)=TRUE              'say we've written some on work file
  158. 1570 '---entry point 2
  159. 1580 '***---Write out array of line numbers to work file---***
  160. 1590 LSET IREC$=MKI$(I): LSET F.N$=VAR.NAMES$(I)
  161. 1600 FOR I2=0 TO MAX.V
  162. 1610  LSET F$(I2)=MKI$(VAR.REF(I,I2))
  163. 1620 NEXT
  164. 1630 REC=REC+1: PUT #2,REC
  165. 1640 VAR.REF(I,0)=0              'reset pointer to first in array
  166. 1650 RETURN
  167. 1660 '***---Search thru reserved words list---***
  168. 1670 FOR I=1 TO NUM.SKIP.WORDS
  169. 1680  IF SKIP.WORDS$(I)=VAR$ GOTO 1710
  170. 1690 NEXT
  171. 1700 KEEP=TRUE: RETURN
  172. 1710 KEEP=NOT(VAR$=SKIP.WORDS$(I))
  173. 1720 RETURN
  174. 1730 '***END
  175. 1740 CLOSE
  176. 1750 RESTORE
  177. 1760 PRINT:PRINT
  178. 1770 INPUT "PRINT ANOTHER FILE (Y/N) ";AN$
  179. 1780 IF AN$="Y" OR AN$="y" THEN GOTO 60
  180. 1790 END
  181. 1800 '*** Init ***
  182. 1810 TRUE=-1: FALSE=0
  183. 1820 I$=SPACE$(1)               'Set i$ to be 1 byte long
  184. 1830 D.Q$=CHR$(34)              'double quote
  185. 1840 SPECIAL.CHARS$="($!%#."    'Chars allowed in variable names
  186. 1850 '***---Basic commands that will not be XREF ---***
  187. 1860 FOR I=1 TO NUM.SKIP.WORDS
  188. 1870  READ SKIP.WORDS$(I)
  189. 1880  DATA "WAIT", "WHILE", "WEND", "XOR"
  190. 1890  DATA "AND", "AS", "DATA", "ELSE", "FOR", "GOSUB", "GOTO", "IF"
  191. 1900  DATA "STICK", "STOP", "SWAP", "TIME$", "USR", "VARPTR", "VARPTR$"
  192. 1910  DATA "RESUME", "RND", "RUN", "SCREEN", "SCRN", "SGN", "SOUND", "SPACE$"
  193. 1920  DATA "POKE", "PMAP", "POS", "PRESET", "RANDOMIZE", "RENAME", "RESET"
  194. 1930  DATA "NAME", "NEW", "OCT$", "ERROR", "OPTION" ,"BASE", "OUT", "PEEK"
  195. 1940  DATA "LSET", "RSET", "MERGE", "MKI$", "MKS$", "MKD$", "MOD", "MOTOR"
  196. 1950  DATA "INPUT$", "INSTR", "INT", "KILL", "LET", "LOC", "LOF", "LPOS"
  197. 1960  DATA "PSET", "PRESET", "PUT", "VIEW", "WINDOW", "HEX$", "IMP", "INP"
  198. 1970  DATA "EXP", "FIELD", "FIX", "FRE", "GET", "LINE", "PAINT", "POINT"
  199. 1980  DATA "DRAW", "END", "EQV", "ERR", "ERL", "PLAY", "TIMER", "PEN", "STRIG"
  200. 1990  DATA "LOCATE", "NEXT", "NOT", "OR", "PRINT", "RETURN", "THEN", "TO"
  201. 2000  DATA "CVD", "DATE$", "DEF" ,"DEFINT", "DEFSNG", "DEFDBL", "DEFSTR"
  202. 2010  DATA "CLEAR", "COLOR", "COM", "COMMON", "CSNG", "CSRLIN", "CVI", "CVS"
  203. 2020  DATA "BSAVE", "SAVE", "CALL", "CAS1", "CDBL", "CHAIN", "CINT", "CIRCLE"
  204. 2030  DATA "WIDTH", "WRITE", "SPC", "ABS", "ASC", "BEEP", "BLOAD", "LOAD"
  205. 2040  DATA "APPEND", "CHR$", "CLS", "DIM", "END", "EOF", "INKEY$", "INPUT"
  206. 2050  DATA "INT", "CLOSE" ,"KEY" ,"ON", "OFF", "LEFT$", "RIGHT$", "MID$"
  207. 2060  DATA "LEN", "LOG", "SIN", "COS", "ATN", "SQR" ,"LPRINT", "OPEN", "OUTPUT"
  208. 2070  DATA "READ", "RESTORE", "STEP", "STR$", "STRING$", "TAB", "USING", "VAL"
  209. 2080 NEXT
  210. 2090 RETURN
  211. 2100 '***Set flags***
  212. 2110 REM
  213. 2120 CK$="Y"
  214. 2130 XREF.LITERALS=(CK$="Y" OR CK$="y")   'set xref.literals
  215. 2140 CK$="Y"
  216. 2150 XREF.LINENUMS=(CK$="Y" OR CK$="y")  'Set Xref.linenums
  217. 2160 RETURN
  218. 2170 OPEN PROGRAM$ FOR INPUT AS #1
  219. 2180 LINE INPUT #1,ST$
  220. 2190 RETURN
  221. 2200 '*********************************
  222. 2210 '*     Final Printout of XREF    *
  223. 2220 '*********************************
  224. 2230 IF LX$="X" THEN GOTO 2250
  225. 2240 LPRINT CHR$(12)
  226. 2250 PCTR=0
  227. 2260 VT$="L"
  228. 2270 GOSUB 2950                          'Heading Routine
  229. 2280 GOSUB 3020                          'Subheading Routine
  230. 2290 '***---Begin Loop to Print All Stored Variables (VT$="L","N","V")---***
  231. 2300 I.PTR=VAR.PTR(0)                     'Set starting point
  232. 2310 FOR JI=1 TO VARS                     'MAINLINE LOOP
  233. 2320  IF VAR.TYPE$(I.PTR)><VT$ THEN VT$=VAR.TYPE$(I.PTR): GOSUB 3020
  234. 2330                                      'if ><, new subheading
  235. 2340  BNAME$=VAR.NAMES$(I.PTR)            'Load name in print buffer
  236. 2350  IF NOT V.FILED(I.PTR) GOTO 2450     'Skip work file retrieval
  237. 2360  FOR IR=1 TO REC                     'Read wrk file til match
  238. 2370   GET #2, IR
  239. 2380   IREC=CVI(IREC$)
  240. 2390   IF IREC><I.PTR GOTO 2440           'Non-matching record
  241. 2400   FOR I2=1 TO MAX.V                  'Found match
  242. 2410    XREF=CVI(F$(I2))                  'set Buffer REFerence number
  243. 2420    GOSUB 2580                        'Load Print Buffer
  244. 2430   NEXT I2
  245. 2440  NEXT IR
  246. 2450  FOR I2=1 TO VAR.REF(I.PTR,0)        'Loop thru vars in memory
  247. 2460   XREF=VAR.REF(I.PTR,I2)             'set Buffer REFerence number
  248. 2470   GOSUB 2580                         'Load Print Buffer
  249. 2480  NEXT I2                             'END MAINLINE LOOP
  250. 2490  GOSUB 2650                          'Clear buffer of this var
  251. 2500  I.PTR=VAR.PTR(I.PTR)                'Set pointer to next var
  252. 2510 NEXT JI                              'END MAINLINE LOOP
  253. 2520 GOSUB 2650                           'Print Final Line from Buffer
  254. 2530 GOSUB 3160                           'Space out final page
  255. 2540 GOTO 1740
  256. 2550 '*********************
  257. 2560 '* LOAD PRINT BUFFER *
  258. 2570 '*********************
  259. 2580 IF BREF.SUB>7 THEN GOSUB 2650: BNAME$="" 'Line is full, so print
  260. 2590 BREF(BREF.SUB)=XREF                 'Load buffer with next refd line
  261. 2600 BREF.SUB=BREF.SUB+1
  262. 2610 RETURN
  263. 2620 '*********************
  264. 2630 '* PRINT DETAIL LINE *
  265. 2640 '*********************
  266. 2650 IF LCTR>60 GOTO 2660 ELSE 2700     'Check for end of page
  267. 2660      GOSUB 3160                    'Finish this page
  268. 2670      GOSUB 2950                    'Heading Routine
  269. 2680      GOSUB 3020                    'Subheading Routine
  270. 2690      GOTO 2650
  271. 2700 N.LEN=LEN(BNAME$)                  'Measure name length
  272. 2710 IF N.LEN=0 THEN LPRINT SPC(28);: GOTO 2830 'No name on this call
  273. 2720 IF N.LEN>16 GOTO 2730 ELSE 2780    'Long name, give it a whole print line
  274. 2730      LPRINT SPC(8);BNAME$
  275. 2740      BNAME$=""                     'reinit buffer name
  276. 2750      LCTR=LCTR+1
  277. 2760      LPRINT SPC(28);
  278. 2770      GOTO 2830
  279. 2780 FOR D=N.LEN+1 TO 20                'Normal size name
  280. 2790  DOT$=DOT$+"."
  281. 2800 NEXT D
  282. 2810 LPRINT SPC(8);BNAME$;DOT$;
  283. 2820 BNAME$="": DOT$=""                 'reinit buffer name area
  284. 2830 FOR R=0 TO 7                       'print references from buffer
  285. 2840  IF BREF(R)=0 GOTO 2880            'done
  286. 2850  LPRINT USING " #####";BREF(R);    'print line number
  287. 2860  BREF(R)=0                         'reinit buffer ref number
  288. 2870 NEXT R
  289. 2880 LPRINT
  290. 2890 LCTR=LCTR+1
  291. 2900 BREF.SUB=0                         'reinit buffer pointer
  292. 2910 RETURN
  293. 2920 '*******************
  294. 2930 '* Heading Routine *
  295. 2940 '*******************
  296. 2950 PCTR=PCTR+1
  297. 2960 LPRINT TAB(10);PROGRAM$;"  XREF Printed on ";D$;" at ";T$;TAB(64);"PAGE";       PCTR
  298. 2970 LCTR=8
  299. 2980 RETURN
  300. 2990 '***********************
  301. 3000 '* Sub-heading Routine *
  302. 3010 '***********************
  303. 3020 IF VT$=PREV.VT$ GOTO 3040
  304. 3030 IF BREF(0)><0 THEN GOSUB 2650      'clear buffer's detail line
  305. 3040 IF LCTR+4>57 THEN GOSUB 3160: GOSUB 2950 'Test end of page
  306. 3050 IF VT$="L" THEN SUBHEAD$="LITERALS":     GOTO 3080
  307. 3060 IF VT$="N" THEN SUBHEAD$="LINE NUMBERS": GOTO 3080
  308. 3070 IF VT$="V" THEN SUBHEAD$="VARIABLES":    GOTO 3080
  309. 3080 LPRINT: LPRINT
  310. 3090 LPRINT SPC(40-(LEN(SUBHEAD$)/2));SUBHEAD$;
  311. 3100 IF VT$=PREV.VT$ THEN LPRINT " (Cont.)";
  312. 3110 PREV.VT$=VT$
  313. 3120 LPRINT: LPRINT
  314. 3130 LCTR=LCTR+4
  315. 3140 RETURN
  316. 3150 '***---End Page Routine---***
  317. 3160 LPRINT CHR$(12);
  318. 3170 LCTR=0
  319. 3180 RETURN
  320. 3190 '***************************************************
  321. 3200 '*  This routine used when LIST only is requested  *
  322. 3210 '***************************************************
  323. 3220 OPEN PROGRAM$ FOR INPUT AS #1
  324. 3230 LPRINT TAB(8);PROGRAM$;"  Printed on ";D$;" at ";T$;TAB(60);"PAGE";PG
  325. 3240 LPRINT:LPRINT
  326. 3250 LINE INPUT #1,FI$
  327. 3260 LPRINT FI$
  328. 3270 IF EOF(1) THEN GOTO 3310
  329. 3280 LET NL=NL+1
  330. 3290 IF NL=54 THEN LET NL=1:PG=PG+1:LPRINT CHR$(12);:GOTO 3230
  331. 3300 GOTO 3250
  332. 3310 LPRINT CHR$(12);
  333. 3320 GOTO 1740
  334. 65399 '** DONE - PRESS ENTER TO RETURN TO MENU **
  335.